home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch9 / Sprites.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-05-28  |  9.5 KB  |  286 lines
  1. VERSION 5.00
  2. Begin VB.Form SpriteForm 
  3.    Caption         =   "Sprites"
  4.    ClientHeight    =   5235
  5.    ClientLeft      =   1320
  6.    ClientTop       =   825
  7.    ClientWidth     =   6870
  8.    LinkTopic       =   "Form1"
  9.    PaletteMode     =   1  'UseZOrder
  10.    ScaleHeight     =   349
  11.    ScaleMode       =   3  'Pixel
  12.    ScaleWidth      =   458
  13.    Begin VB.TextBox txtFramesPerSecond 
  14.       Height          =   285
  15.       Left            =   1440
  16.       TabIndex        =   4
  17.       Text            =   "20"
  18.       Top             =   4920
  19.       Width           =   375
  20.    End
  21.    Begin VB.TextBox txtNumObjects 
  22.       Height          =   285
  23.       Left            =   1440
  24.       TabIndex        =   3
  25.       Text            =   "20"
  26.       Top             =   4560
  27.       Width           =   375
  28.    End
  29.    Begin VB.CommandButton cmdStart 
  30.       Caption         =   "Start"
  31.       Default         =   -1  'True
  32.       Height          =   495
  33.       Left            =   2160
  34.       TabIndex        =   1
  35.       Top             =   4620
  36.       Width           =   855
  37.    End
  38.    Begin VB.PictureBox picCanvas 
  39.       AutoRedraw      =   -1  'True
  40.       Height          =   4455
  41.       Left            =   0
  42.       ScaleHeight     =   293
  43.       ScaleMode       =   3  'Pixel
  44.       ScaleWidth      =   453
  45.       TabIndex        =   0
  46.       Top             =   0
  47.       Width           =   6855
  48.    End
  49.    Begin VB.Label Label1 
  50.       Caption         =   "Frames per second:"
  51.       Height          =   255
  52.       Index           =   0
  53.       Left            =   0
  54.       TabIndex        =   5
  55.       Top             =   4920
  56.       Width           =   1455
  57.    End
  58.    Begin VB.Label Label1 
  59.       Caption         =   "Number of objects:"
  60.       Height          =   255
  61.       Index           =   1
  62.       Left            =   0
  63.       TabIndex        =   2
  64.       Top             =   4560
  65.       Width           =   1455
  66.    End
  67. Attribute VB_Name = "SpriteForm"
  68. Attribute VB_GlobalNameSpace = False
  69. Attribute VB_Creatable = False
  70. Attribute VB_PredeclaredId = True
  71. Attribute VB_Exposed = False
  72. Option Explicit
  73. Private xmin As Integer
  74. Private ymin As Integer
  75. Private xmax As Integer
  76. Private ymax As Integer
  77. Private NumSprites As Integer
  78. Private Sprites() As Sprite
  79. Private Playing As Boolean
  80. Private NumPlayed As Long
  81. Private BitmapWid As Long
  82. Private BitmapHgt As Long
  83. Private BitmapNumBytes As Long
  84. Private Bytes() As Byte
  85. ' Bitmap Information
  86. Private Type BITMAP
  87.     bmType As Long
  88.     bmWidth As Long
  89.     bmHeight As Long
  90.     bmWidthBytes As Long
  91.     bmPlanes As Integer
  92.     bmBitsPixel As Integer
  93.     bmBits As Long
  94. End Type
  95. Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
  96. Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
  97. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  98. ' Play the animation.
  99. Private Sub PlayImages(ByVal ms_per_frame As Long)
  100. Dim sprite_number As Integer
  101. Dim next_time As Long
  102.     ' Get the current time.
  103.     next_time = GetTickCount()
  104.     ' Start the animation.
  105.     Do While Playing
  106.         NumPlayed = NumPlayed + 1
  107.         ' Restore the background.
  108.         SetBitmapBits picCanvas.Image, BitmapNumBytes, Bytes(1, 1)
  109.         ' Draw and move the sprites.
  110.         For sprite_number = 1 To NumSprites
  111.             Sprites(sprite_number).DrawSprite picCanvas
  112.             Sprites(sprite_number).MoveSprite xmin, xmax, ymin, ymax
  113.         Next sprite_number
  114.         ' Wait until it's time for the next frame.
  115.         next_time = next_time + ms_per_frame
  116.         WaitTill next_time
  117.     Loop
  118. End Sub
  119. ' Draw some random rectangles on the bacground.
  120. Private Sub DrawBackground()
  121. Dim i As Integer
  122. Dim Wid As Single
  123. Dim Hgt As Single
  124.     ' Start with a clean slate.
  125.     picCanvas.Line (0, 0)-(picCanvas.ScaleWidth, picCanvas.ScaleHeight), picCanvas.BackColor, BF
  126.     ' Draw some rectangles.
  127.     For i = 1 To 10
  128.         Hgt = 10 + Rnd * xmax / 3
  129.         Wid = 10 + Rnd * ymax / 3
  130.         picCanvas.Line (Int(Rnd * xmax), Int(Rnd * ymax))-Step(Hgt, Wid), QBColor(Int(Rnd * 16)), BF
  131.     Next i
  132.     ' Make the rectangles part of the permanent background.
  133.     picCanvas.Picture = picCanvas.Image
  134. End Sub
  135. ' Generate some random data.
  136. Private Sub InitializeData()
  137. Dim obj As Object
  138. Dim i As Integer
  139.     ' See how many objects there should be.
  140.     If Not IsNumeric(txtNumObjects.Text) Then Exit Sub
  141.     NumSprites = CInt(txtNumObjects.Text)
  142.     If NumSprites < 1 Then Exit Sub
  143.     ' Create the sprites.
  144.     ReDim Sprites(1 To NumSprites)
  145.     For i = 1 To NumSprites
  146.         ' Pick a random sprite type.
  147.         Select Case Int(3 * Rnd)
  148.             Case 0
  149.                 Set Sprites(i) = NewRectangle()
  150.             Case 1
  151.                 Set Sprites(i) = NewTriangle()
  152.             Case 2
  153.                 Set Sprites(i) = NewBall()
  154.         End Select
  155.     Next i
  156. End Sub
  157. ' Create and initialize a random BallSprite.
  158. Private Function NewBall() As BallSprite
  159. Dim new_sprite As BallSprite
  160. Dim new_color As Long
  161.     ' Make the new sprite.
  162.     Set new_sprite = New BallSprite
  163.     ' Pick a color other than 7 (gray).
  164.     new_color = Int(15 * Rnd)
  165.     If new_color >= 7 Then new_color = new_color + 1
  166.     ' Initialize the sprite.
  167.     new_sprite.InitializeBall _
  168.         Int(15 * Rnd + 5), _
  169.         Int(xmax * Rnd), _
  170.         Int(ymax * Rnd), _
  171.         Int(11 * Rnd - 5), Int(11 * Rnd - 5), _
  172.         QBColor(new_color)
  173.     Set NewBall = new_sprite
  174. End Function
  175. ' Create and initialize a random TriangleSprite.
  176. Private Function NewTriangle() As TriangleSprite
  177. Const PI = 3.14159265
  178. Const THIRD_CIRCLE = 2 * PI / 3
  179. Const PI_OVER_8 = PI / 8
  180. Const PI_OVER_16 = PI / 16
  181. Dim new_sprite As TriangleSprite
  182. Dim new_color As Long
  183.     ' Make the new sprite.
  184.     Set new_sprite = New TriangleSprite
  185.     ' Pick a color other than 7 (gray).
  186.     new_color = Int(15 * Rnd)
  187.     If new_color >= 7 Then new_color = new_color + 1
  188.     ' Initialize the sprite.
  189.     new_sprite.InitializeTriangle _
  190.         Int(xmax * Rnd), Int(ymax * Rnd), _
  191.         Int(11 * Rnd - 5), Int(11 * Rnd - 5), _
  192.         Int(15 * Rnd + 10), THIRD_CIRCLE * Rnd, _
  193.         Int(15 * Rnd + 10), THIRD_CIRCLE * (1 + Rnd), _
  194.         Int(15 * Rnd + 10), THIRD_CIRCLE * (2 + Rnd), _
  195.         0, PI_OVER_8 * Rnd - PI_OVER_16, _
  196.         QBColor(new_color)
  197.     Set NewTriangle = new_sprite
  198. End Function
  199. ' Create and initialize a random RectangleSprite.
  200. Private Function NewRectangle() As RectangleSprite
  201. Const PI = 3.14159265
  202. Const PI_OVER_2 = PI / 2
  203. Const PI_OVER_8 = PI / 8
  204. Const PI_OVER_16 = PI / 16
  205. Dim new_sprite As RectangleSprite
  206. Dim new_color As Integer
  207.     ' Make the new sprite.
  208.     Set new_sprite = New RectangleSprite
  209.     ' Pick a color other than 7 (gray).
  210.     new_color = Int(15 * Rnd)
  211.     If new_color >= 7 Then new_color = new_color + 1
  212.     ' Initialize the sprite.
  213.     new_sprite.InitializeRectangle _
  214.         Int(20 * Rnd + 10), _
  215.         Int(20 * Rnd + 10), _
  216.         Int(xmax * Rnd), Int(ymax * Rnd), _
  217.         Int(11 * Rnd - 5), Int(11 * Rnd - 5), _
  218.         PI_OVER_2 * Rnd, _
  219.         PI_OVER_8 * Rnd - PI_OVER_16, _
  220.         QBColor(new_color)
  221.     Set NewRectangle = new_sprite
  222. End Function
  223. ' Start the animation.
  224. Private Sub cmdStart_Click()
  225.     If Playing Then
  226.         Playing = False
  227.         cmdStart.Caption = "Stopped"
  228.         cmdStart.Enabled = False
  229.     Else
  230.         cmdStart.Caption = "Stop"
  231.         Playing = True
  232.         InitializeData
  233.         PlayData
  234.         Playing = False
  235.         cmdStart.Caption = "Start"
  236.         cmdStart.Enabled = True
  237.     End If
  238. End Sub
  239. ' Play the animation.
  240. Private Sub PlayData()
  241. Dim ms_per_frame As Long
  242. Dim start_time As Single
  243. Dim stop_time As Single
  244. Dim bm As BITMAP
  245.     ' Draw a random background.
  246.     DrawBackground
  247.     ' Save the background bitmap data.
  248.     GetObject picCanvas.Image, Len(bm), bm
  249.     BitmapWid = bm.bmWidthBytes
  250.     BitmapHgt = bm.bmHeight
  251.     BitmapNumBytes = BitmapWid * BitmapHgt
  252.     ReDim Bytes(1 To bm.bmWidthBytes, 1 To bm.bmHeight)
  253.     GetBitmapBits picCanvas.Image, BitmapNumBytes, Bytes(1, 1)
  254.     ' See how fast we should go.
  255.     If Not IsNumeric(txtFramesPerSecond.Text) Then _
  256.         txtFramesPerSecond.Text = "10"
  257.     ms_per_frame = 1000 \ CLng(txtFramesPerSecond.Text)
  258.     ' Start the animation.
  259.     NumPlayed = 0
  260.     start_time = Timer
  261.     PlayImages ms_per_frame
  262.     ' Display results.
  263.     stop_time = Timer
  264.     MsgBox "Displayed" & Str$(NumPlayed) & _
  265.         " frames in " & _
  266.         Format$(stop_time - start_time, "0.00") & _
  267.         " seconds (" & _
  268.         Format$(NumPlayed / (stop_time - start_time), "0.00") & _
  269.         " FPS)."
  270. End Sub
  271. Private Sub Form_Load()
  272.     picCanvas.FillStyle = vbFSSolid
  273. End Sub
  274. ' Make the ball picCanvas nice and big.
  275. Private Sub Form_Resize()
  276. Const GAP = 3
  277.     txtFramesPerSecond.Top = ScaleHeight - GAP - txtFramesPerSecond.Height
  278.     Label1(0).Top = txtFramesPerSecond.Top
  279.     txtNumObjects.Top = txtFramesPerSecond.Top - GAP - txtNumObjects.Height
  280.     Label1(1).Top = txtNumObjects.Top
  281.     cmdStart.Top = (txtNumObjects.Top + txtFramesPerSecond.Top + txtFramesPerSecond.Height - cmdStart.Height) / 2
  282.     picCanvas.Move 0, 0, ScaleWidth, txtNumObjects.Top - GAP
  283.     xmax = picCanvas.ScaleWidth - 1
  284.     ymax = picCanvas.ScaleHeight - 1
  285. End Sub
  286.